COMMENT ⊗   VALID 00009 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	BEGIN "TEST"
C00004 00003	SUBR MKVERTICES
C00006 00004	SUBR ECROSS(ITG I,J)
C00008 00005	RECURSIVE PROCEDURE QSORT (INTEGER I,J REAL CUT)
C00009 00006	SUBR MATEVV (INTEGER V1,V2)
C00010 00007	SUBR MKEDGES
C00012 00008	SUBR EECROSS
C00013 00009	α MAIN EXECUTION
C00014 ENDMK
C⊗;
BEGIN "TEST"
	REQUIRE "ABBREV[SYS,BGB]" SOURCE_FILE;
	REQUIRE "DPYIII[SYS,BGB]" SOURCE_FILE;
	SAFE ITG ARRAY DPYBUF[0:3000];

α VERTEX "NODES";
	SAFE REAL ARRAY X,Y,Z[1:100];
	SAFE ITG ARRAY VX,VY,PED[1:100];

α EDGE "NODES";
	SAFE ITG ARRAY PVT,NVT,EDG[0:1000];
	SAFE REAL ARRAY AA,BB,CC,DD[1:1000];

	ITG I,J,K,RRMAX,RMAX;
	ITG VCNT,ECNT,FCNT;
	ITG COMCNT,EECNT;

α MICRO LISP;
	SAFE ITG ARRAY FS[1:4000];ITG FSPTR;
	ITG SUBR XWD(ITG A,B); S⊂ HRLZ 1,A;HRR 1,B;⊃;
	ITG SUBR CONS(ITG A,B); ⊂ ITG I;I←FSPTR;
	FSPTR←FS[I];FS[I]←XWD(A,B);RETURN(I);⊃;

	DEFINE CAR(A)="(FS[A] LSH -18)";
	DEFINE CDR(A)="(FS[A] LAND '777777)";
SUBR MKVERTICES;
BEGIN "MKVERTICES"
FOR I←1 THRU VCNT DO
BEGIN "MKV"
	X[1]←X[4]←Y[1]←Y[2]← -500;
	X[2]←X[3]←Y[3]←Y[4]← +500;
	FOR I←1 THRU 4 DO
BEGIN
	AIVECT(X[I]-6,Y[I]-6);
	DPYSST("* "&CVS(I));
END;
	FOR I←5 THRU VCNT DO
BEGIN
	X[I] ← RAN(0)*1000 - 500;
	Y[I] ← RAN(0)*1000 - 500;
	AIVECT(X[I]-6,Y[I]-6);
	DPYSST("* "&CVS(I));
END;
END "MKV";
END "MKVERTICES";

SUBR ECOEF (ITG E);
BEGIN "ECOEF"
	ITG V1,V2,A,B; REAL C,D;
	V1 ← PVT[E];
	V2 ← NVT[E];
	A ← Y[V1]-Y[V2];
	B ← X[V2]-X[V1];
	C ← X[V1]*Y[V2] - X[V2]*Y[V1];
	D ← SQRT(A*A + B*B);
	AA[E] ← A/D;
	BB[E] ← B/D;
	CC[E] ← C/D;
	DD[E] ←   D;;
END "ECOEF";
SUBR ECROSS(ITG I,J);
BEGIN "ECROSS"
	ITG V1,V2,U1,U2;
	REAL D1,D2;
α EPSILON;
	DEFINE PE="0.0001";
	DEFINE NE="-0.0001";

	IF PVT[I]=0 ∨ PVT[J]=0 THEN RETURN;

α TEST FOR FOUR DISTINCT VERTICES;
	V1 ← PVT[I];	V2 ← NVT[I];
	U1 ← PVT[J];	U2 ← NVT[J];
	IF V1=U1 ∨ V1=U2 ∨ V2=U1 ∨ V2=U2 THEN RETURN;

α COMPARE COUNTER;
	COMCNT←COMCNT+1;

α TEST FOR SPAN OVERLAP;
	IF (X[U1] MAX X[U2]) < (X[V1] MIN X[V2]) THEN RETURN;
	IF (Y[U1] MAX Y[U2]) < (Y[V1] MIN Y[V2]) THEN RETURN;
	IF (X[V1] MAX X[V2]) < (X[U1] MIN X[U2]) THEN RETURN;
	IF (Y[V1] MAX Y[V2]) < (Y[U1] MIN Y[U2]) THEN RETURN;

α TEST FOR HALF PLANE CROSSING;
	D1 ← AA[I]*X[U1] + BB[I]*Y[U1] + CC[I];
	D2 ← AA[I]*X[U2] + BB[I]*Y[U2] + CC[I];
	IF (D1≥PE ∧ D2≥PE) ∨ (D1≤NE ∧ D2≤NE) THEN RETURN;

α TEST FOR HALF PLANE CROSSING;
	D1 ← AA[J]*X[V1] + BB[J]*Y[V1] + CC[J];
	D2 ← AA[J]*X[V2] + BB[J]*Y[V2] + CC[J];
	IF (D1≥PE ∧ D2≥PE) ∨ (D1≤NE ∧ D2≤NE) THEN RETURN;

α DELETE LONGER EDGE;
	IF DD[J] > DD[I] THEN I↔J;
	PVT[I]←NVT[I]←0;
END "ECROSS";
RECURSIVE PROCEDURE QSORT (INTEGER I,J; REAL CUT);
BEGIN "QSORT"
	INTEGER L,H;

α BUBBLE SORT THE FEW;
	IF (J-I) ≤ 6 THEN ⊂
	FOR L←I THRU J-1 DO FOR H←L+1 THRU J DO
	IF DD[EDG[L]] < DD[EDG[H]] THEN EDG[L]↔EDG[H]; RETURN;⊃;

α PARTITION SORT THE MANY;
	L ← I; H ← J;
	WHILE TRUE DO
	BEGIN
		WHILE L<H ∧ DD[EDG[L]] ≥ CUT DO L←L+1;
		WHILE L<H ∧ DD[EDG[H]] < CUT DO H←H-1;
		IF L=H THEN ⊂ L←L-1;DONE;⊃;
		EDG[L]↔EDG[H];
	END;
	IF I<L THEN QSORT(I,L, (DD[EDG[I]] + DD[EDG[L]])/2);
	IF H<J THEN QSORT(H,J, (DD[EDG[H]] + DD[EDG[J]])/2);
END "QSORT";
SUBR MATEVV (INTEGER V1,V2);
BEGIN "MATEVV"
	ITG I,EL,E;
	IF (X[V1]-X[V2])↑2 + (Y[V1]-Y[V2])↑2 > RRMAX THEN  RETURN;
	IF V2>V1 THEN V1↔V2;

	EL ← PED[V1];
	WHILE EL≠0 DO ⊂ E←CAR(EL);
	IF V1=PVT[E] ∧ V2=NVT[E] THEN RETURN ELSE EL←CDR(EL);⊃;

	ECNT ← ECNT+1;
	PVT[ECNT] ← V1;
	NVT[ECNT] ← V2;

	PED[V1] ← CONS(ECNT,PED[V1]);
	PED[V2] ← CONS(ECNT,PED[V2]);

END "MATEVV";
SUBR MKEDGES;
BEGIN "MKEDGES"
	ECNT ← 0;
	RRMAX ← RMAX*RMAX;

α XSORT THE VERTICES;
	FOR I←1 THRU VCNT DO EDG[I]←I;
	ARRBLT(DD[1],X[1],VCNT);
	QSORT(1,VCNT,(X[1]+X[VCNT])/2);
	ARRBLT(VX[1],EDG[1],VCNT);

α YSORT THE VERTICES;
	FOR I←1 THRU VCNT DO EDG[I]←I;
	ARRBLT(DD[1],Y[1],VCNT);
	QSORT(1,VCNT,(Y[1]+Y[VCNT])/2);
	ARRBLT(VY[1],EDG[1],VCNT);

	FOR I←1 THRU VCNT-1 DO
	FOR J←I+1 THRU VCNT DO
	IF VX[J] - VX[I] < RMAX THEN
	MATEVV(VX[I],VX[J]) ELSE DONE;

	FOR I←1 THRU VCNT-1 DO
	FOR J←I+1 THRU VCNT DO
	IF VY[J] - VY[I] < RMAX THEN
	MATEVV(VY[I],VY[J]) ELSE DONE;

	FOR K←1 THRU ECNT DO ECOEF(K);
END "MKEDGES";
SUBR EECROSS;
BEGIN "EECROSS"
	ITG V1,V2,E1,E2,E3,EL1,EL2,EL3;
	FOR V1←1 THRU VCNT DO
BEGIN "V1"
	EL1 ← PED[V1];
	WHILE EL1≠0 DO
BEGIN "EL1"
	E1←CAR(EL1);
	EL1←CDR(EL1);
	IF (V2←PVT[E1])=0 THEN CONTINUE
			  ELSE IF V1=V2 THEN V2←NVT[E1];
	EL3 ← PED[V1];
	WHILE EL3≠0 DO
BEGIN "EL3"
	E3←CAR(EL3);
	EL3←CDR(EL3);
	EL2 ← PED[V2];
	WHILE EL2≠0 DO
	⊂ E2←CAR(EL2);
	  EL2←CDR(EL2);
	  IF E2<E3 THEN ECROSS(E2,E3);⊃;
END "EL3";
END "EL1";
END "V1";
END "EECROSS";
α MAIN EXECUTION;
	RAN(37);

WHILE TRUE DO
BEGIN "FOREVER"
	RMAX ← 4000;
	VCNT ← 15;
	ECNT ← 0;
	ARRCLR(PVT);ARRCLR(NVT);ARRCLR(EDG);
	ARRCLR(VX);ARRCLR(VY);ARRCLR(PED);
	ARRCLR(FS);

	FOR I←1 THRU 3999 DO FS[I]←I+1;
	FS[4000]←0;
	FSPTR←1;

	DPYSET(DPYBUF);
	DPYBIG(1);
	MKVERTICES;
	MKEDGES;
	EECROSS;
	FOR K←1 THRU ECNT DO
 	IF PVT[K]≠0 THEN
	⊂ AIVECT(X[PVT[K]],Y[PVT[K]]);
	  AVECT(X[NVT[K]],Y[NVT[K]]);⊃;
	DPYOUT(1);
	INCHRW;
END "FOREVER"
END "TEST";